Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/src-16f.lha/compiler/assembler.lisp

Text File | 1992-02-24 | 45.5 KB | 1,399 lines

;;; -*- Package: ASSEMBLER; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or [e-mail].
;;;
(ext:file-comment
  "$Header: assembler.lisp,v 1.25 92/02/24 06:18:26 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; Assembler for the compiler.
;;;
;;; Written by William Lott.  Instruction definition stuff rewritten by Rob
;;; MacLachlan to support instruction scheduling.
;;;
(in-package "ASSEMBLER" :nicknames '("ASSEM"))
(use-package "C")
(use-package "EXTENSIONS")
(use-package "KERNEL")

;;; Import freelisting allocators...
(import '(c::really-make-instruction c::make-instruction
                     c::unmake-instruction))
(export '(
      define-format define-argument-type define-fixup-type
      define-instruction define-pseudo-instruction
      define-resources define-register-file

      make-fixup fixup fixup-p fixup-name fixup-flavor fixup-offset

      gen-label label label-id label-position emit-label
      make-segment insert-segment assemble inst align

      expand-pseudo-instructions
      finalize-segment *current-position* emit-code-vector
      dump-segment nuke-segment count-instructions
      relative-branch unconditional-branch delayed-branch nop delayed-load
      assembly-call))


;;; Meta-compile-time data structures.

(eval-when (compile load eval)

;;; Meta-compile-time representation of an instruction's properties, used to
;;; compute the miscellanous values of the INSTRUCTION-INFO, below.
;;;
(defstruct (meta-instruction
        (:make-load-form-fun :just-dump-it-normally))
  ;;
  ;; Lists of resource names used and clobbered.
  (use nil :type list :read-only t)
  (clobber nil :type list :read-only t)
  ;;
  ;; True if this instruction can never be moved, nor have anything moved over
  ;; it.  Used for branches and other odd things.
  (pinned nil :type boolean :read-only t)
  ;;
  ;; The cost of this instruction, in cycles (or whatever.)
  (cost 1 :type index :read-only t)
  ;;
  ;; List of boolean attribute names.
  (attributes nil :type list :read-only t)
  ;;
  ;; Some other info used by the optimizer, organized as a plist.  The values
  ;; of the properties are forms that are evaluated at load-time to produce the
  ;; real plist values.
  (properties nil :type list :read-only t))


;;; The info about a single instruction format.
;;;
(defstruct (cformat (:conc-name format-) (:constructor make-format))
  ;;
  ;; The name of this format.  User supplied.
  (name nil :type symbol :read-only t)
  ;;
  ;; The number of bits an instruction of this format takes.
  (length 0 :type index :read-only t)
  ;;
  ;; A list of all the fields of this format.
  (fields nil :type list :read-only t)
  ;;
  ;; The META-INSTRUCTION holding default values for instruction attributes.
  (meta-instruction (required-argument) :type meta-instruction :read-only t)
  ;;
  ;; The name of the generated function that emits an instruction of this
  ;; format.  This function expects to be passed the output buffer vector and
  ;; the location at which to begin emitting, followed by an integer argument
  ;; for each field defined in the format.
  (emitter nil :type symbol :read-only t))


;;; Info about a single field of an instruction format.
;;;
(defstruct field
  ;;
  ;; Its name -- user supplied.
  (name nil :type symbol :read-only t)
  ;;
  ;; The default value for this field (if any).
  (default nil :read-only t)
  ;;
  ;; T iff this field can be defaulted.
  (default-p nil :type (member t nil) :read-only t)
  ;;
  (default-type nil :type (or null symbol cons))
  ;;
  ;; Flags indicating whether this field is read or written.  If either is
  ;; true, then the actual argument must be a TN.  This is a default that can
  ;; be overridden in the instruction definition.
  (read-p nil :type boolean :read-only t)
  (write-p nil :type boolean :read-only t))


;;; Info about a field in a particular instruction flavor.  This is the
;;; instantiation of a format field.
;;;
(defstruct field-parse
  ;;
  ;; This is the field name copied from the format.
  (name nil :type symbol :read-only t)
  ;;
  ;; The way this field is supplied:
  (kind (required-argument) :type (member :constant :argument :same-as)
    :read-only t)
  ;;
  ;; The constant value, argument type or same-as argument name.
  (what (required-argument) :read-only t)
  ;;
  ;; A function name that is applied to the field value to get the true value,
  ;; or null if none.
  (function nil :read-only t)
  ;;
  ;; If true, the cons (Actual-Type . Function) for a special argument field.
  ;; This is just the result of GETHASH on WHAT in the backend special argument
  ;; types.
  (special-type nil :type (or cons null) :read-only t)
  ;;
  ;; If :ARGUMENT, the list of all the slot accessor names for slots that hold
  ;; this value in the INSTRUCTION structure.  If a slot is both read and
  ;; written, then there will be two elements in this list.
  (accessors nil :type list)
  ;;
  ;; If :ARGUMENT, the name of the argument to the selector function that will
  ;; hold the value.
  (argument nil :type symbol)
  ;;
  ;; Flags indicating whether this field is read or written.  If either is
  ;; true, then the actual argument must be a TN.  These are defaulted from the
  ;; format field, but may be overridden.
  (read-p nil :type boolean :read-only t)
  (write-p nil :type boolean :read-only t))


;;; The result of parsing a particular instruction flavor.
;;;
(defstruct instruction-flavor
  ;;
  ;; The name of this flavor's instruction.
  (name (required-argument) :type symbol :read-only t)
  ;;
  ;; The format of this instruction flavor.
  (format (required-argument) :type cformat :read-only t)
  ;;
  ;; This flavor's ordinal number.
  (number (required-argument) :type index :read-only t)
  ;;
  ;; The list of FIELD-INFO structures.
  (fields (required-argument) :type list :read-only t)
  ;;
  ;; The Lisp types of the arguments to this flavor (used to select this over
  ;; other flavors.)
  (arg-types (required-argument) :type list :read-only t)
  ;;
  ;; The number of arguments to this flavor.
  (nargs (required-argument) :type index :read-only t)
  ;;
  ;; The META-INSTRUCTION representing all the defaulted attributes of this
  ;; instruction.
  (meta-instruction (required-argument) :type meta-instruction :read-only t)
  ;;
  ;; The lexical variable we close over to get our hands on the INSTRUCTION-INFO.
  (info-var (gensym) :type symbol :read-only t))

); eval-when (compile load eval)


;;; Assemble time data structures.

;;; Specials used during code generation.  See the defvars below.

(proclaim '(special *current-segment* *current-vop*
            *fixups* *current-position*))

;;;
;;; The assembler runs in several passes.  This first pass generates a doubly
;;; linked list of different kind of node structures, and the later passes
;;; grovel this list.

;;; Generic node, everything the assembler needs to emit in the instruction
;;; stream includes this.
;;;
(defstruct (node
        (:print-function %print-node))
  ;; The ir2 vop this node was emited on behalf of or other useful
  ;; identification info.  Used during trace file dumps.
  (vop *current-vop*)
  ;; The next and previous node (if any).
  (next nil :type (or null node))
  (prev nil :type (or null node)))


(def-boolean-attribute instruction
  ;;
  ;; True if this is a branch to an assembler label, which must be a constant
  ;; argument to the instruction.
  relative-branch
  ;;
  ;; True if this branch is always taken.
  unconditional-branch
  ;;
  ;; True if this is a branch instruction with a delay slot that we want to
  ;; fill.
  delayed-branch
  ;;
  ;; True if this is a NOP instruction (which is initially placed in delay
  ;; slots).
  nop
  ;;
  ;; True if this is a load with a delay slot that we want to fill.  The result
  ;; of this instruction must not be read in the delay slot.
  delayed-load
  ;;
  ;; True if this instruction is used to call assembly routines.  Used by
  ;; lifetime checking to detect these calls (which are not flagged by
  ;; vop-info-save-p.)
  assembly-call)

;;; This structure holds run-time info about a particular instruction that is
;;; in common with all instances of that instruction.
;;;
(defstruct instruction-info
  ;;
  ;; The name of this instruction.
  (name (required-argument) :type symbol :read-only t)
  ;;
  ;; A small integer indicating which flavor of this instruction that we are
  ;; describing here.
  (flavor (required-argument) :type index)
  ;;
  ;; The kind of instruction.
  (kind (required-argument) :type (member :pseudo :normal) :read-only t)
  ;;
  ;; The maximum length of this instruction.
  (length (required-argument) :type index :read-only t)
  ;;
  ;; The sets of resources that this instruction uses and clobbers.
  (use 0 :type index :read-only t)
  (clobber 0 :type index :read-only t)
  ;;
  ;; True if this instruction can never be moved, nor have anything moved over
  ;; it.  Used for branches and other odd things.
  (pinned nil :read-only t)
  ;;
  ;; Some boolean attributes of this instruction used by the optimizer.
  (attributes 0 :type attributes :read-only t)
  ;;
  ;; The cost of this instruction, in cycles (or whatever.)
  (cost 0 :type index :read-only t)
  ;;
  ;; Some other info used by the optimizer, organized as a plist.
  (properties nil :type list :read-only t)
  ;;
  ;; Function that converts this instruction into real stuff.
  ;;
  ;; If a :PSEUDO instruction, then this function is called with the
  ;; INSTRUCTION structure during the pseudo-instruction expansion pass.  The
  ;; result of the expansion should be inserted into the current segment.  The
  ;; pseudo-instruction argument list is in the first constant slot.
  ;;
  ;; If a :NORMAL instruction, then this function is called at the end of
  ;; assembly to actually emit the bits.  It is called with the output buffer
  ;; and starting index, and the INSTRUCTION structure.
  (emitter (required-argument) :type function :read-only t))


;;; DEFINE-INSTRUCTION-STRUCTURE  --  Internal
;;;
;;;    This macro is used to define the instruction structure with some set of
;;; possible arguments and results.  This must be set up for worst-case for all
;;; the hardware that we want to simultaneously support.  If you change the
;;; below call to this macro, you have to recompile the assembler.
;;;
(defmacro define-instruction-structure (&key arguments results constants)
  (declare (type (integer 1 10) arguments results constants))
  (collect ((arg-names)
        (res-names)
        (const-names)
        (slots))
    (macrolet ((frob (count res what type)
         `(dotimes (i ,count)
            (let ((name (format nil "~:@(~R~)" i)))
              (,res (symbolicate "INSTRUCTION-" ,what name))
              (slots `(,(symbolicate ,what name) nil :type ,',type))))))
      (frob arguments arg-names "ARGUMENT-" (or tn null))
      (frob results res-names "RESULT-" (or tn null))
      (frob constants const-names "CONSTANT-" t))
    (let ((all-accessors (append (arg-names) (res-names) (const-names))))
      `(progn
     (eval-when (compile load eval)
       (defconstant instruction-argument-slots ',(arg-names))
       (defconstant instruction-result-slots ',(res-names))
       (defconstant instruction-constant-slots ',(const-names))
       (defconstant instruction-slot-order ',all-accessors))
     (export ',all-accessors)

     (declaim (inline really-make-instruction))
     (defstruct (instruction
             (:include node)
             (:print-function %print-instruction)
             (:constructor really-make-instruction
                   (prev info ,@(mapcar #'car (slots)))))
       ;;
       ;; The INSTRUCTION-INFO for this instruction.
       (info nil :type instruction-info)
       ;;
       ;; The arg, result and constant slots.  Args and results are the TNs
       ;; read & written by this instruction, or NIL if the slot is not used.
       ;; Constants can be anything.
       ,@(slots))))))
;;;
(define-instruction-structure :arguments 4  :results 1  :constants 3)


;;; DO-ARGUMENTS, DO-RESULTS, DO-CONSTANTS  --  Public
;;;
(macrolet ((frob (name slots)
         `(defmacro ,name ((var instruction &optional res) &body body)
        (once-only ((n-inst instruction))
          `(block nil
             ,@(mapcar #'(lambda (x)
                   `(let ((,var (,x ,n-inst)))
                      (when ,var
                    ,@body)))
                   ,slots)
             ,res)))))
  (frob do-arguments instruction-argument-slots)
  (frob do-results instruction-result-slots)
  (frob do-constants instruction-constant-slots))


;;; INSTRUCTION-xxx  --  Interface
;;;
(declaim (inline instruction-name instruction-length))
(defun instruction-name (x)
  (instruction-info-name (instruction-info x)))
(defun instruction-length (x)
  (instruction-info-length (instruction-info x)))

;;; Labels.
;;;
(defstruct (label
        (:include node (vop nil))
        (:constructor gen-label)
        (:print-function %print-label))
  ;; The current guess at where this instruction is located in the instruction
  ;; stream.
  (%position nil :type (or null fixnum)))


;;; Segments.
;;;
(defstruct (segment
        (:include label)
        (:print-function %print-label)
        (:constructor %make-segment))
  ;; The last node inserted in this segment.  Additional nodes are inserted
  ;; after it.
  (last nil :type (or null node)))

;;; Alignment tweek.
;;;
(defstruct (alignment
        (:include node)
        (:print-function %print-alignment))
  ;; The number of low order bits that must be zero.
  (bits 0 :type (integer 0 32)))

;;; A fixup record.
;;;
(defstruct (fixup
        (:print-function %print-fixup)
        (:constructor make-fixup (name flavor &optional offset)))
  ;; The name and flavor of the fixup.  The assembler makes no assumptions
  ;; about the contents of these fields; their semantics are imposed by the
  ;; dumper.
  name
  flavor
  ;; An optional offset from whatever external label this fixup refers to.
  offset)


(declaim (freeze-type node))


;;;; Print functions for structures

(defun %print-node (node stream depth)
  (declare (ignore node depth))
  (write-string "#<node???>" stream))

(defun %print-instruction (inst stream depth)
  (declare (ignore depth))
  (format stream "#<inst ~A>" (instruction-name inst)))

(defun %print-label (label stream depth)
  (declare (ignore depth))
  (if *print-escape*
      (format stream "#<~A ~D>" (type-of label) (label-id label))
      (format stream "L~D" (label-id label))))

(defun %print-alignment (align stream depth)
  (declare (ignore depth))
  (format stream "#<alignment to ~D bits>" (alignment-bits align)))

(defun %print-fixup (fixup stream depth)
  (declare (ignore depth))
  (format stream "#<~S fixup ~S~@[ offset=~S~]>"
      (fixup-flavor fixup)
      (fixup-name fixup)
      (fixup-offset fixup)))


;;;; Hash tables and lookup functions.

(eval-when (compile load eval)

;;; All the currently defined instruction formats.
;;;
(defun format-or-lose (format)
  (or (gethash format (backend-instruction-formats *target-backend*))
      (error "Unknown instruction format: ~S" format)))

;;; All the currently known flavors of instructions.  The print name of the
;;; instruction name is used as the key (to keep from having to export all the
;;; instruction names from some package).  The associated datum is an a-list
;;; mapping the number of arguments to the parser information.
;;;
(defun parser-or-lose (inst num-args)
  (let ((entries (or (gethash (symbol-name inst)
                  (backend-instruction-flavors *target-backend*))
             (error "Unknown instruction: ~S" inst))))
    (if (atom entries)
    entries
    (cdr (or (assoc num-args entries :test #'eql)
         (error "Invalid number of arguments for ~S instruction: ~S"
            inst num-args))))))


;;; RESOURCE-OR-LOSE  --  Internal
;;;
;;;    Return the resource number of the Named resource or die trying.
;;;
(defun resource-or-lose (name)
  (or (position name (backend-assembler-resources *target-backend*))
      (error "~S is not a known resource." name)))


;;; PARSE-RESOURCES  --  Internal
;;;
;;;    Return a bit-mask with the named bits set.
;;;
(defun parse-resources (names)
  (let ((res 0))
    (dolist (name names)
      (setf (ldb (byte 1 (resource-or-lose name)) res) 1))
    res))


;;;; Utilities:

(defun maybe-ash (form amt)
  (if (zerop amt)
      form
      `(ash ,form ,amt)))

(defun maybe-funcall (function arg)
  (if function
      `(,function ,arg)
      arg))


;;; NTH-ARGUMENT  --  Internal
;;;
;;;    Return the name of the N'th argument to a selector function.
;;;
(defun nth-argument (arg-num)
  (intern (format nil "ARG-~D" arg-num) (symbol-package 'foo)))


;;;; Instruction parsing:

;;; PARSE-INSTRUCTION-FIELDS  --  Internal
;;;
;;;    Return a list of Field-Parse structures corresponding to a particular
;;; instruction flavor.  Fields is a list of the field specs, and Format is the
;;; instruction format.
;;;
(defun parse-instruction-fields (name format fields)
  (declare (type cformat format))
  (let ((format-fields (format-fields format)))
    (collect ((fields-done)
          (res))
      (dolist (field fields)
    (destructuring-bind (field-name &key constant argument same-as function
                    (read nil read-p) (write nil write-p)
                    type inverse-function mask)
                field
      (declare (ignore type inverse-function mask))
      (let ((field (find field-name format-fields :key #'field-name)))
        (unless field
          (error "In instruction ~S: format ~S doesn't have a field named ~S."
             name (format-name format) field-name))
        (when (member field-name (fields-done))
          (error "Field ~S listed twice in instruction ~S." field-name name))
        (fields-done field-name)
        (unless (eql (count-if #'identity (list constant argument same-as)) 1)
          (error "Must specify one of :constant, :argument, or :same-as ~
                    for field ~S of format ~S in instruction ~S."
             field-name (format-name format) name))
        (res (make-field-parse
          :name field-name
          :kind (cond (constant :constant)
                  (argument :argument)
                  (t
                   (assert same-as)
                   :same-as))
          :what (or constant argument same-as)
          :special-type
          (gethash argument
               (backend-special-arg-types *target-backend*))

          :function function
          :read-p (if read-p
                  read
                  (and (not constant)
                   (field-read-p field)))
          :write-p (if write-p
                   write
                   (and (not constant)
                    (field-write-p field))))))))

      (dolist (format-field format-fields)
    (unless (member (field-name format-field) (fields-done))
      (cond ((field-default-p format-field)
         (res (make-field-parse :name (field-name format-field)
                    :kind :constant
                    :what (field-default format-field))))
        ((field-default-type format-field)
         (res (make-field-parse :name (field-name format-field)
                    :kind :argument
                    :what (field-default-type format-field)
                    :special-type
                     (gethash (field-default-type format-field)
                          (backend-special-arg-types *target-backend*))
                    :read-p (field-read-p format-field)
                    :write-p (field-write-p format-field))))
        (t
         (error
          "Field ~S of format ~S in instruction ~S cannot be defaulted."
          (field-name format-field) (format-name format) name)))))

      (res))))


;;; SELECT-ACCESSORS  --  Internal
;;;
;;;    Annotate a list of FIELD-INFO structures with the appropriate
;;; instruction slot accessors and argument variables.  We ignore :CONSTANT
;;; fields, since we tacitly assume that they never are TNs (which eliminates
;;; the need to explicitly clear any default :READ or :WRITE attributes.)
;;;
;;;    We do three passes over the fields.  In the first pass, we assign the
;;; variables for arguments.  In the second pass, we copy the variables for
;;; same-as arguments.  In the final pass, we set up accessors for both.
;;;
(defun select-accessors (fields)
  (declare (list fields))
  (let ((argument instruction-argument-slots)
    (result instruction-result-slots)
    (constant instruction-constant-slots)
    (arg-num 0))
    (dolist (field fields)
      (when (eq (field-parse-kind field) :argument)
    (setf (field-parse-argument field) (nth-argument arg-num))
    (incf arg-num)))

    (dolist (field fields)
      (when (eq (field-parse-kind field) :same-as)
    (let ((as (find (field-parse-what field) fields
            :key #'field-parse-name)))
      (unless (and as
               (eq (field-parse-kind as) :argument))
        (error "Value for :SAME-AS in field ~S is not an argument field:~
                ~%  ~S"
           (field-parse-name field) (field-parse-what field)))
      (setf (field-parse-argument field) (field-parse-argument as)))))


    (dolist (field fields)
      (macrolet ((getacc (where)
           `(push (or (pop ,where)
                  (error "Too few ~S fields configured in the use ~
                          of DEFINE-INSTRUCTION-STRUCTURE."
                     ',where))
              (field-parse-accessors field))))
    (unless (eq (field-parse-kind field) :constant)
      (let ((read-p (field-parse-read-p field))
        (write-p (field-parse-write-p field)))
        (cond ((or read-p write-p)
           (when read-p (getacc argument))
           (when write-p (getacc result)))
          (t
           (getacc constant))))))))
  (undefined-value))


;;; FIND-ARG-TYPES  --  Internal
;;;
;;;    Given a list of fields, return a list of the Lisp type of each argument.
;;;
(defun find-arg-types (fields)
  (declare (list fields))
  (collect ((res))
    (dolist (field fields)
      (when (eq (field-parse-kind field) :argument)
    (res (or (car (field-parse-special-type field))
         (field-parse-what field)))))
    (res)))


;;; PARSE-META-INSTRUCTION  --  Internal
;;;
;;;    Return a META-INSTRUCTION structure describing the result of parsing the
;;; specified Options, taking defaults from the Default meta-instruction.
;;;
(defun parse-meta-instruction (options default)
  (declare (list options) (type meta-instruction default))
  (destructuring-bind (&key (use nil use-p) (clobber nil clobber-p)
                (pinned nil pinned-p)
                (attributes nil attributes-p) (cost nil cost-p)
                disassem-printer disassem-control
                properties)
      options
    (declare (ignore disassem-printer disassem-control))
    (let ((props (copy-list (meta-instruction-properties default))))
      (do ((prop properties (cddr prop)))
      ((endp prop))
    (setf (getf props (first prop)) (second prop)))
      (make-meta-instruction
       :use (if use-p use (meta-instruction-use default))
       :clobber (if clobber-p clobber (meta-instruction-clobber default))
       :pinned (if pinned-p pinned (meta-instruction-pinned default))
       :cost (if cost-p cost (meta-instruction-cost default))
       :attributes (if attributes-p
               attributes
               (meta-instruction-attributes default))
       :properties props))))


;;; PARSE-INSTRUCTION-FLAVOR  --  Internal
;;;
;;;    Return an INSTRUCTION-FLAVOR structure describing a particular flavor of
;;; the instruction Name.  Spec is the Flavor spec and Num is the flavor
;;; number.  Options is the options supplied for the whole instruction definition.
;;;
(defun parse-instruction-flavor (name num options spec)
  (declare (symbol name) (type index num) (list options))
  (destructuring-bind (format &rest fields)
              spec
    (multiple-value-bind (format flav-options)
             (if (consp format)
                 (values (first format) (rest format))
                 (values format nil))
      (let* ((format (format-or-lose format))
         (fields (parse-instruction-fields name format fields)))
    (select-accessors fields)
    (make-instruction-flavor
     :name name
     :format format
     :number num
     :fields fields
     :arg-types (find-arg-types fields)
     :nargs (count :argument fields :key #'field-parse-kind)
     :meta-instruction
     (parse-meta-instruction
      flav-options
      (parse-meta-instruction
       options
       (format-meta-instruction format))))))))


;;;; Instruction info creation:

;;; MAKE-EMITTER-FUNCTION  --  Internal
;;;
;;;    Return an emitter function for the specified instruction Flavor.  This
;;; function just binds each field name to its actual value, and then calls the
;;; format emit function on those values.  Finding the value is only
;;; non-trivial when it is an argument, in which case we must access the value
;;; from the INSTRUCTION structure, calling an additional conversion function
;;; when the type is a special argument kind.
;;;
(defun make-emitter-function (flavor)
  (declare (type instruction-flavor flavor))
  (let ((format (instruction-flavor-format flavor)))
    (collect ((bindings)
          (same-as-bindings))
      (dolist (field (instruction-flavor-fields flavor))
    (let ((name (field-parse-name field))
          (fun (field-parse-function field))
          (what (field-parse-what field)))
      (ecase (field-parse-kind field)
        (:constant
         (bindings `(,name ,(maybe-funcall fun what))))
        (:same-as
         (same-as-bindings `(,name ,(maybe-funcall fun what))))
        (:argument
         (bindings
          `(,name
        ,(maybe-funcall
          fun
          (maybe-funcall (cdr (field-parse-special-type field))
                 `(,(first (field-parse-accessors field))
                   inst)))))))))

      `#'(lambda (buffer where inst)
       (declare (ignorable buffer where inst))
       (let* (,@(bindings)
          ,@(same-as-bindings))
         (,(format-emitter format)
          buffer
          where
          ,@(mapcar #'field-name (format-fields format))))))))


;;; CREATE-INSTRUCTION-INFO  --  Internal
;;;
;;;    Return a form to create the INSTRUCTION-INFO structure for a particular
;;; instruction Flavor.
;;;
(defun create-instruction-info (flavor)
  (declare (type instruction-flavor flavor))
  (let ((meta-inst (instruction-flavor-meta-instruction flavor)))
    `(make-instruction-info
      :name ',(instruction-flavor-name flavor)
      :flavor ,(instruction-flavor-number flavor)
      :kind :normal
      :length ,(format-length (instruction-flavor-format flavor))
      :use ,(parse-resources (meta-instruction-use meta-inst))
      :clobber ,(parse-resources (meta-instruction-clobber meta-inst))
      :pinned ,(meta-instruction-pinned meta-inst)
      :attributes (instruction-attributes ,@(meta-instruction-attributes meta-inst))
      :cost ,(meta-instruction-cost meta-inst)
      :properties (list ,@(collect ((res))
                (do ((prop (meta-instruction-properties meta-inst)
                       (cddr prop)))
                ((endp prop)
                 (res))
                  (res `',(first prop))
                  (res (second prop)))))
      :emitter ,(make-emitter-function flavor))))


;;;; Selector function creation:

;;; CREATE-INSTRUCTION-FORM  --  Internal
;;;
;;;    Return a form to create an instruction of the specified Flavor, getting
;;; the arguments from the argument variables.
;;;
(defun create-instruction-form (flavor)
  (declare (type instruction-flavor flavor))
  (let ((args (make-list (length instruction-slot-order)
             :initial-element nil)))
    (dolist (field (instruction-flavor-fields flavor))
      (dolist (slot (field-parse-accessors field))
    (setf (elt args (position slot instruction-slot-order))
          (field-parse-argument field))))
    `(make-instruction after ,(instruction-flavor-info-var flavor) ,@args)))


;;; DISPATCHER-FOR-FLAVORS  --  Internal
;;;
;;;    Do stuff to select the appropriate flavor of instruction Name from
;;; Flavors, all of which have Nargs arguments.  We return a form that does any
;;; necessary dispatching and creates an instruction of the appropriate flavor.
;;;
(defun dispatcher-for-flavors (name nargs flavors)
  (iterate frob
       ((index 0)
        (flavors flavors))
    (cond ((= index nargs)
       (unless (= (length flavors) 1)
         (error "Multiple flavors of ~S have the same type signature: ~S"
            name flavors))
       (create-instruction-form (first flavors)))
      (t
       (collect ((tests))
         (dolist (flavor flavors)
           (let* ((type (nth index (instruction-flavor-arg-types flavor)))
              (found (or (assoc type (tests) :test #'equal)
                 (let ((res (list type)))
                   (tests res)
                   res))))
         (nconc found (list flavor))))
           (if (rest (tests))
           `(etypecase ,(nth-argument index)
              ,@(mapcar #'(lambda (test)
                    `(,(car test)
                      ,(frob (1+ index) (cdr test))))
                (tests)))
           (frob (1+ index) (cdr (first (tests))))))))))


;;; MAKE-SELECTOR-DECLARATION  --  Internal
;;;
;;;    Return a list of the types of all possible arguments to the specified
;;; flavors in each position, for use in a function type declaration.  This is
;;; our main mechanism for enforcing instruction argument types.
;;;
(defun make-selector-declaration (nargs flavors)
  (declare (list flavors))
  (loop for i below nargs
    collect `(or ,@(loop for flavor in flavors
             collect (elt (instruction-flavor-arg-types flavor) i)))))


;;; MAKE-SELECTOR-FUNCTIONS  --  Internal
;;;
;;;    Return a list of forms to define selector functions and instantiate them
;;; in the back end, given a list of instruction flavors.
;;;
(defun make-selector-functions (flavors)
  (let ((by-counts (make-hash-table))
    (name (instruction-flavor-name (first flavors))))
    (dolist (flav flavors)
      (let ((nargs (instruction-flavor-nargs flav)))
    (setf (gethash nargs by-counts)
          (nconc (gethash nargs by-counts) (list flav)))))
    (collect ((entries)
          (forms))
      (loop for similar-flavors being each hash-value in by-counts do
    (let* ((nargs (instruction-flavor-nargs (first similar-flavors)))
           (defun-name (intern (format nil "~:@(append-~R-arg-~A-inst~)"
                       nargs name))))
      (entries (cons nargs defun-name))
      (forms
       `(declaim (ftype (function ,(make-selector-declaration
                    nargs similar-flavors)
                      instruction)
                ,defun-name)))
      (forms
       `(defun ,defun-name
           ,(loop for i below nargs
              collect (nth-argument i))
          (let* ((segment *current-segment*)
             (after (segment-last segment))
             (inst ,(dispatcher-for-flavors name nargs similar-flavors)))
        (setf (node-next after) inst)
        (setf (segment-last segment) inst)
        inst)))))
      (forms `(eval-when (compile load eval)
        (setf (gethash ,(symbol-name name)
                   (backend-instruction-flavors *target-backend*))
              ',(entries))))
      (forms))))

); eval-when (compile load eval)


;;;; Definition macros.


;;; DEFINE-RESOURCES  --  Public
;;;
(defmacro define-resources (&rest names)
  "List the random resources that instructions can frob."
  `(eval-when (compile load eval)
     (setf (backend-assembler-resources *target-backend*) ',names)))


;;; DEFINE-ARGUMENT-TYPE  --  Public
;;;
(defmacro define-argument-type (name &rest options
                     &key (type t)
                          function
                      disassem-printer
                      sign-extend
                      disassem-use-label)
  "Define a ``magic'' argument type.  When NAME is used as an argument type
  use TYPE in the etypecase instead, and apply FUNCTION to the argument."
  (declare (ignore disassem-printer sign-extend disassem-use-label))
  `(progn
     (eval-when (compile load eval)
       (setf (gethash ',name
              (backend-special-arg-types *target-backend*))
         (cons ,type
           ',function)))
     ,(disassem:gen-field-type-decl-form name options)
     ',name))


(defmacro define-fixup-type (type &rest dat-args)
  "Define argument TYPE as being a fixup.  TYPE is automatically registered
  as a ``magic'' argument type with a function to record the fixup when
  the instruction using this argument is emitted."
  (let ((record-function (intern (concatenate 'simple-string
                          "RECORD-"
                          (symbol-name type)
                          "-FIXUP")))
    (arg-type (intern (concatenate 'simple-string
                       (symbol-name type)
                       "-FIXUP"))))
    `(progn
       (defun ,record-function (fixup)
     (push (list ',type fixup *current-position*) *fixups*)
     (or (fixup-offset fixup) 0))
       (define-argument-type ,arg-type
     :type 'fixup
     :function ,record-function
     ,@dat-args)
       ',type)))


;;; The place where we pick up defaults for instruction format meta-instruction
;;; options.
;;;
(eval-when (compile load eval)
  (defparameter *format-default-options* (make-meta-instruction)))

(defmacro define-format ((format bits &rest options) &rest fields)
  "DEFINE-FORMAT (Format Bits Keywords*)
   {(Field-Name Byte-Spec Field-Keywords*)}*
  Define a new instruction format named FORMAT and being BITS bits wide.
  Possible keywords for fields are :DEFAULT, :FUNCTION, :READ, and :WRITE."
  (unless (zerop (rem bits vm:*assembly-unit-length*))
    (warn "Format ~S uses ~D bits, which is not a multiple of ~
           vm:*assembly-unit-length* (~D)"
      format bits vm:*assembly-unit-length*))
  (let ((mask (ash -1 bits))
    (args nil)
    (bindings nil)
    (bytes (make-array (truncate bits vm:*assembly-unit-length*)
               :initial-element nil))
    (format-fields nil)
    (types nil)
    (binding-types nil))
    (dolist (field fields)
      (destructuring-bind (name bytespec &key (default 0 default-p) default-type function
                read write)
              field
    (let* ((bytespec (eval bytespec))
           (size (byte-size bytespec))
           (posn (byte-position bytespec)))
      (unless (zerop (ldb bytespec mask))
        (warn "Field ~S overlaps in ~S"
          name format))
      (setf mask (dpb -1 bytespec mask))
      (push name args)
      (when function
        (push `(,name (,function ,name)) bindings))
      (multiple-value-bind
          (start offset)
          (floor posn vm:*assembly-unit-length*)
        (let ((end (floor (1- (+ posn size))
                  vm:*assembly-unit-length*)))
          (cond ((zerop size))
            ((= start end)
             (push (maybe-ash `(ldb (byte ,size 0) ,name)
                      offset)
               (svref bytes start)))
            (t
             (push (maybe-ash
                `(ldb (byte ,(- vm:*assembly-unit-length*
                        offset)
                    0)
                  ,name)
                offset)
               (svref bytes start))
             (do ((index (1+ start) (1+ index)))
             ((>= index end))
               (push
            `(ldb (byte ,vm:*assembly-unit-length*
                    ,(- (* vm:*assembly-unit-length*
                       (- index start))
                    offset))
                  ,name)
            (svref bytes index)))
             (let ((len (rem (+ size offset)
                     vm:*assembly-unit-length*)))
               (push
            `(ldb (byte ,(if (zerop len)
                     vm:*assembly-unit-length*
                     len)
                    ,(- (* vm:*assembly-unit-length*
                       (- end start))
                    offset))
                  ,name)
            (svref bytes end)))))))
      (cond ((zerop size)
         (push `(ignore ,name) types))
        (function
         (push `(type (signed-byte ,(1+ size)) ,name)
               binding-types))
        (t
         (push `(type (signed-byte ,(1+ size)) ,name) types)))
      (push `(make-field :name ',name
                 :default ',default
                 :default-p ',default-p
                 :default-type ',default-type
                 :read-p ',read
                 :write-p ',write)
        format-fields))))
    (ecase (backend-byte-order *target-backend*)
      (:big-endian
       (setf bytes (nreverse bytes)))
      (:little-endian))
    (unless (= mask -1)
      (warn "Empty space in ~S; assuming zero filled." format))
    (let ((emitter-fn (intern (concatenate 'simple-string
                       (symbol-name format)
                       "-FORMAT-EMITTER"))))
      `(progn
     (defun ,emitter-fn (buffer where ,@(nreverse args))
       (declare
        (type (simple-array (unsigned-byte ,vm:*assembly-unit-length*)
                (*))
          buffer)
        (fixnum where)
        (ignorable buffer where)
        ,@(nreverse types))
       (let ,(nreverse bindings)
         (declare ,@(nreverse binding-types))
         ,@(let ((sets nil))
         (dotimes (i (length bytes))
           (push `(setf (aref buffer (+ where ,i))
                (logior ,@(svref bytes i)))
             sets))
         (nreverse sets))))
     (eval-when (compile load eval)
       (setf (gethash ',format
              (backend-instruction-formats *target-backend*))
         (make-format
          :name ',format
          :meta-instruction
          ',(parse-meta-instruction options *format-default-options*)
          :length ,(ceiling bits vm:*assembly-unit-length*)
          :fields (list ,@(nreverse format-fields))
          :emitter ',emitter-fn)))
     ,(disassem:gen-inst-format-decl-form format bits fields options)
     ',format))))

(defmacro define-instruction ((name &rest options) &rest flavors)
  "DEFINE-INSTRUCTION (Name {Key Value}*)) Flavor-Spec*
  Define a new instruction named NAME.  Each instruction may have several
  flavors selected according to argument count and type.  A Flavor-Spec is:
      (Format {(Field {Field-Key Value}*)}*)

  Each flavor specifies what format and where to get the values to fill its
  fields.  Each field must specify exactly one of :CONSTANT, :ARGUMENT, or
  :SAME-AS, indicating the source of the value for that field.  If a field
  defined in the format is not specified, then its value is taken from the
  format default (if any.)  These are the Field-Keys:

  :CONSTANT Value
      Specifies that this field always has the specified constant value.

  :ARGUMENT Type
      Specifies that this the value of this field is obtained from an argument,
      and must be of the specified Type.  Type may be any Lisp type specifier,
      or an argument type defined by DEFINE-ARGUMENT-TYPE.

  :SAME-AS Field
      Specifies that this field has the same value as the other named field.

  :READ T-or-NIL
  :WRITE T-or-NIL
      If true in an argument field, indicates that the argument is a TN which
      is read (or written) by this instruction.

  :FUNCTION Fun-Form
      Fun-Form specifies a function that does instruction specific
      transformation of the numeric value of a field.  This in called after
      any DEFINE-ARGUMENT-TYPE :FUNCTION, but before any DEFINE-FORMAT :FUNCTION."

  (let ((parsed-flavors
     (loop for spec in flavors and num from 0
       collect (parse-instruction-flavor name num options spec))))
    `(let ,(mapcar #'(lambda (flav)
               `(,(instruction-flavor-info-var flav)
             ,(create-instruction-info flav)))
           parsed-flavors)
       ,@(make-selector-functions parsed-flavors)
       ,(disassem:gen-inst-decl-form name flavors options)
       ',name)))


(defmacro define-pseudo-instruction (name max-bits lambda-list &body body)
  "Define NAME as being a pseudo-instruction that can be up to MAX-BITS wide.
  LAMBDA-LIST and BODY specify the function to use to expand the
  pseudo-instruction into other instructions."
  (let ((append-name (intern (concatenate 'simple-string
                      "APPEND-"
                      (string name)
                      "-PSEUDO-INSTRUCTION")))
    (expander-name (intern (concatenate 'simple-string
                        (string name)
                        "-PSEUDO-INSTRUCTION-EXPANDER")))
    (n-info (gensym))
    (args (make-list (length instruction-slot-order) :initial-element nil)))
    (setf (elt args (position (first instruction-constant-slots)
                  instruction-slot-order))
      'args)
    `(progn
       (defun ,expander-name ,lambda-list
     ,@body)
       (let ((,n-info (make-instruction-info
               :name ',name
               :flavor 0
               :kind :pseudo
               :length ',(ceiling max-bits vm:*assembly-unit-length*)
               :emitter #',expander-name)))
     (defun ,append-name (&rest args)
       (let* ((segment *current-segment*)
          (after (segment-last segment))
          (inst (make-instruction after ,n-info ,@args)))
         (setf (node-next after) inst)
         (setf (segment-last segment) inst)
         inst)))

       (eval-when (compile load eval)
     (setf (gethash ,(symbol-name name)
            (backend-instruction-flavors *target-backend*))
           ',append-name)))))


;;;; Noise to emit instructions.

(defvar *current-segment*)
(defvar *current-vop*)

(defmacro inst (name &rest args)
  `(,(parser-or-lose name (length args)) ,@args))

(defun align (bits)
  (let* ((last (segment-last *current-segment*))
     (align (make-alignment :prev last :bits bits)))
    (setf (node-next last) align)
    (setf (segment-last *current-segment*) align)
    align))

(defun emit-label (label)
  (when (label-prev label)
    (error "Label ~S has already been emitted somewhere else." label))
  (setf (label-vop label) *current-vop*)
  (let ((last (segment-last *current-segment*)))
    (setf (label-prev label) last)
    (setf (node-next last) label))
  (setf (segment-last *current-segment*) label))

(defun make-segment ()
  (let ((segment (%make-segment)))
    (setf (segment-last segment) segment)
    segment))

(defun insert-segment (segment)
  (when (segment-prev segment)
    (error "Segment ~S has already been inserted somewhere else." segment))
  (let ((last (segment-last *current-segment*)))
    (setf (node-next last) segment)
    (setf (segment-prev segment) last)
    (setf (segment-last *current-segment*) (segment-last segment))))


(defmacro assemble ((segment &optional (vop nil vop-p))
            &body forms)
  `(let ((*current-segment* ,segment)
     ,@(when vop-p
         `((*current-vop* ,vop))))
     (when (segment-prev *current-segment*)
       (error "Segment ~S has already been inserted -- can't extend it now."
          *current-segment*))
     ,@forms))



;;;; emit-code-vector

(defconstant output-buffer-size (* 8 1024))

(defvar *output-buffer*
  (make-array output-buffer-size
          :element-type '(unsigned-byte #.vm:*assembly-unit-length*)
          :initial-element 0))

(defvar *current-position*)
(declaim (type index *current-position*))

(defvar *fixups*)

(declaim (inline node-size))
(defun node-size (current worst-case-p set-label-locs)
  (etypecase current
    (instruction
     (instruction-length current))
    (label
     (when set-label-locs
       (setf (label-%position current) *current-position*))
     0)
    (alignment
     (if worst-case-p
     (ash 1 (alignment-bits current))
     (logand (- *current-position*) (1- (ash 1 (alignment-bits current))))))))


(defmacro do-nodes ((node-var segment worst-case set-label-locs)
            &body forms)
  `(let ((*current-position* 0))
     (do ((,node-var ,segment (node-next ,node-var)))
     ((null ,node-var))
       ,@forms
       (incf *current-position*
         (node-size ,node-var ,worst-case ,set-label-locs)))
     *current-position*))

(defun expand-pseudo-instructions (segment)
  ;; Make a first guess at the position of things.
  (do-nodes (node segment t t))
  ;; Expand any pseduo-instructions.
  (do-nodes (node segment nil t)
    (when (instruction-p node)
      (let ((info (instruction-info node)))
    (when (eq (instruction-info-kind info) :pseudo)
      (let ((new-seg (make-segment)))
        (assemble (new-seg (node-vop node))
          (apply (instruction-info-emitter info)
             (instruction-constant-zero node)))
        (cond ((eq new-seg (segment-last new-seg))
           ;; Nothing was inserted, just delete this puppy.
           (when (node-next node)
             (setf (node-prev (node-next node))
               (node-prev node)))
           (setf (node-next (node-prev node))
             (node-next node)))
          (t
           ;; Link the segment contents in place of node.
           (setf (node-next (node-prev node))
             (segment-next new-seg))
           (setf (node-prev (segment-next new-seg))
             (node-prev node))
           (setf (node-next (segment-last new-seg))
             (node-next node))
           (when (node-next node)
             (setf (node-prev (node-next node))
               (segment-last new-seg)))))
        (setf node new-seg))))))
  (undefined-value))

(defun finalize-segment (segment)
  ;; Determine the actual positions.
  (do-nodes (node segment nil t)))


(defun emit-code-vector (stream segment)
  ;; Emit the instructions.
  (let ((offset 0)
    (*fixups* nil))
    (do-nodes (node segment nil nil)
      (let ((size (node-size node nil nil)))
    (when (> (+ offset size) output-buffer-size)
      (write-string *output-buffer* stream :end offset)
      (setf offset 0))
    (etypecase node
      (instruction
       (funcall (instruction-info-emitter (instruction-info node))
            *output-buffer*
            offset
            node))
      (label)
      (alignment
       (fill *output-buffer* 0 :start offset :end (+ offset size))))
    (incf offset size)))
    (unless (zerop offset)
      (write-string *output-buffer* stream :end offset))
    *fixups*))


(defun label-position (label)
  (or (label-%position label)
      (error "Label ~S was never emitted." label)))


;;; DUMP-NODE  --  Internal
;;;
(defun dump-node (node)
  (etypecase node
    (label
     (format t "~A:~%" node))
    (instruction
     (format t "~8X:~0,8T~A~@[~0,8T~{~A~^, ~}~]~%"
         *current-position*
         (instruction-info-name (instruction-info node))
         (collect ((args))
           (do-results (arg node)
         (args (c::location-print-name arg)))
           (do-arguments (arg node)
         (args (c::location-print-name arg)))
           (do-constants (arg node)
         (args arg))
           (args))))
    (alignment
     (format t "~8X:~0,8T.align~16T~D~%"
         *current-position*
         (alignment-bits node)))))

;;; DUMP-SEGMENT  --  Interface
;;;
;;;    Print out the assembly code in a segment.  If supplied, Start and End
;;; delimit a subsequence to print.  Markers is an alist (node . format-args)
;;; of stuff to print out before the specified nodes.
;;;
(defun dump-segment (segment &key
                 ((:stream *standard-output*) *standard-output*)
                 start end markers)
  (let ((last-vop nil)
    (started (not start)))
    (do-nodes (node segment nil nil)
      (when (eq node start) (setq started t))
      (when (eq node end) (return))
      (when started
    (let ((vop (node-vop node)))
      (when (and vop (not (eq last-vop vop)))
        (terpri)
        (princ "VOP ")
        (if (c::vop-p vop)
        (c::print-vop vop)
        (format t "~S~%" vop)))
      (setf last-vop vop))
    (dolist (marker markers)
      (when (and (eq (car marker) node) (cdr marker))
        (apply #'format t (cdr marker))))
    (dump-node node))))
  (values))

(defun count-instructions (fun segment elsewhere &optional (what :cost))
  (let ((elsewherep nil)
    (last-vop nil)
    (count 0))
    (flet ((note-vop-counts ()
         (when last-vop
           (funcall fun last-vop count elsewherep))
         (setf last-vop nil)))
      (do-nodes (node segment nil nil)
    (let ((vop (node-vop node))
          (value (ecase what
               (:cost
            (and (instruction-p node)
                 (instruction-info-cost (instruction-info node))))
               (:size
            (node-size node nil nil)))))
      (when value
        (cond ((eq vop last-vop)
           (incf count value))
          (t
           (note-vop-counts)
           (setf last-vop vop)
           (setf count value)))))
    (when (eq node elsewhere)
      (note-vop-counts)
      (setf elsewherep t)))
      (note-vop-counts))))

(defun nuke-segment (segment)
  (do ((node segment next)
       (next (node-next segment) (when next (node-next next))))
      ((null node))
    (typecase node
      (instruction
       (unmake-instruction node))
      (t
       (setf (node-vop node) nil)
       (setf (node-prev node) nil)
       (setf (node-next node) nil)))))